home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 19 / madtrb11.zip / LISTSUBS.PAS < prev    next >
Pascal/Delphi Source File  |  1985-07-13  |  5KB  |  158 lines
  1. PROGRAM ListSubs;
  2.  
  3. {
  4. This program prints a listing of all procedure and function
  5. delcarations in a Pascal source program.
  6.  
  7. Source: "LISTSUBS: A Procedure/Function Lister", TUG Lines Volume I Issue 5
  8. Author: Fritz Ziegler
  9. Date: 7/15/84
  10. Application: All systems
  11. }
  12.  
  13. type
  14.   fil_type = text;
  15.   filname_type = string[14]; { x:yyyyyyyy.zzz }
  16.   fil_lin_type = string[255];
  17.   maxstring = string[255];
  18.   identifier_type = string[127];
  19.  
  20. var
  21.   fil : fil_type;
  22.   filname : filname_type;
  23.  
  24. procedure close_files(var fil : fil_type);
  25.   begin { close_files }
  26.     close(fil);
  27.   end; { close_files }
  28.  
  29. procedure get_filname(var filname : filname_type);
  30.   begin { get_filname }
  31.     filname := '';
  32.     writeln;
  33.     write('List procedures and functions on what file (Q to quit) ? ');
  34.     readln(filname);
  35.     writeln;
  36.   end; { get_filname }
  37.  
  38. procedure open_files(filname : filname_type; var fil : fil_type);
  39.   begin { open_files }
  40.     assign(fil, filname);
  41.     reset(fil);
  42.   end; { open_files }
  43.  
  44. procedure print_procfunc_list(var fil : fil_type;
  45.                                   filname: filname_type);
  46.   var
  47.     fil_lin : fil_lin_type;
  48.     first_word : identifier_type;
  49.     is_cont_lin : boolean;
  50.  
  51.   function is_procfunc(var fil_lin: fil_lin_type;
  52.                        var is_cont_lin : boolean): boolean;
  53.  
  54.     procedure get_first_word(fil_lin : fil_lin_type;
  55.                              var first_word: identifier_type);
  56.       label return;
  57.       var
  58.         i, i2 : integer;
  59.       begin { get_first_word }
  60.         first_word := '';
  61.         for i := 1 to length(fil_lin) do
  62.           begin
  63.             if fil_lin[i] <> ' ' then
  64.               begin
  65.                 for i2 := i to length(fil_lin) do
  66.                   begin
  67.                     if fil_lin[i2] <> ' ' then
  68.                       first_word := concat(first_word, upcase(fil_lin[i2]))
  69.                     else
  70.                       begin
  71.                         goto return;
  72.                       end; { else }
  73.                   end; { for }
  74.               end; { if }
  75.           end; { for }
  76.       return:
  77.       end; { get_first_word }
  78.  
  79.     procedure set_cont_flag(fil_lin : fil_lin_type;
  80.                             first_word: identifier_type;
  81.                             var is_cont_lin: boolean);
  82.       begin {set_cont_flag}
  83.         if (first_word = 'PROCEDURE') or
  84.            (first_word = 'FUNCTION') or
  85.            (first_word = 'PROGRAM') then
  86.           if (pos('(', fil_lin) <> 0) and (pos(')', fil_lin) = 0) then
  87.             is_cont_lin := true;
  88.       end; {set_cont_flag}
  89.  
  90.     begin { is_procfunc }
  91.       get_first_word(fil_lin, first_word);
  92.       if not is_cont_lin then set_cont_flag(fil_lin,
  93.                                             first_word, is_cont_lin);
  94.       if (first_word = 'PROCEDURE') or
  95.          (first_word = 'FUNCTION') or
  96.          (first_word = 'PROGRAM') or
  97.          (first_word = 'END.') or
  98.          (is_cont_lin) then
  99.          is_procfunc := true
  100.       else
  101.         is_procfunc := false;
  102.     end; { is_procfunc }
  103.  
  104.   procedure clrsav_cont_flag(fil_lin : fil_lin_type;
  105.                              var is_cont_lin: boolean);
  106.     begin {clrsav_cont_flag}
  107.        if (pos(')', fil_lin) <> 0) then
  108.             is_cont_lin := false;
  109.     end; {clrsav_cont_flag}
  110.  
  111.   begin { print_procfunc_list }
  112.     writeln('                               ***  LISTSUBS  ***');
  113.     writeln(' ');
  114.     writeln('                A list of subprograms for the file ', filname);
  115.     writeln(' ');
  116.     writeln(' ');
  117.     writeln(lst, '                               ***  LISTSUBS  ***');
  118.     writeln(lst, ' ');
  119.     writeln(lst, '                A list of subprograms for the file ',
  120.             filname);
  121.     writeln(lst, ' ');
  122.     writeln(lst, ' ');
  123.     is_cont_lin := false;
  124.     while not eof(fil) do
  125.       begin
  126.         fil_lin := '';
  127.         readln(fil, fil_lin);
  128.         if is_procfunc(fil_lin, is_cont_lin) then
  129.           begin
  130.             writeln(fil_lin);
  131.             writeln(' ');
  132.             writeln(lst, fil_lin);
  133.             writeln(lst, ' ');
  134.           end; { if }
  135.         if is_cont_lin then clrsav_cont_flag(fil_lin, is_cont_lin);
  136.       end; { while }
  137.   end; { print_procfunc_list }
  138.  
  139. procedure upc_filname(var filname : filname_type);
  140.   var
  141.     i : integer;
  142.   begin { upc_filname }
  143.     for i := 1 to length(filname) do filname[i] := upcase(filname[i]);
  144.   end; { upc_filname }
  145.  
  146. begin { main program }
  147.  
  148.   get_filname(filname);
  149.   upc_filname(filname);
  150.   while filname <> 'Q' do
  151.     begin
  152.       open_files(filname, fil);
  153.       print_procfunc_list(fil, filname);
  154.       close_files(fil);
  155.       get_filname(filname);
  156.       upc_filname(filname);
  157.     end; { while }
  158. end. { listsubs }